Printout of Fonts Installed
This is a good example of the help and co-operation provided by a variety of members of the e-group, as the printing code has been adapted from that to be found in Alyce's e-book, and the latest method of accessing the registry by Stefan at megabit@t-online.at
Those using Windows 95 or 98 will have no trouble creating a list of all the fonts installed from the registry, by running the first program below, the code originally provided by Alyce and others. You will see that the fonts.txt list contains information in addition to just the font descriptions required, hence the conversions needed, while assigning the data to the font$ array. Also for some reason here Fixedsys is not found, so it needs to be added. The second main program is intended for all versions of Windows, although the printing routine can be used with the first program.
However with the advent of Windows XP, life has become more complicated, as the information regarding the fonts is not so easily accessed, and located in a different area of the registry, and takes a few seconds to save in fonts.lst. If you were to inspect this file with notepad before it is deleted by the program, you will see it contains a great deal of non ASCII characters, hence the need for the CleanString$ function kindly provided by Stefan. I also found it is still necessary to read the data saved from the file fonts.txt to persuade the printer to use the desired fonts.
If you attempt to display too many fonts, such as by altering the program you may see a warning that you have exceeded the maximum allowed by LB or Windows. Just click the notice until all requested have been displayed.
Gordon Sweet
' WINDOWS 95/98 ONLY
dim info$(1,1) : dim fontList$(2000) : f = 0
'** export font list from registry.
NowDir$=GetShortPathName$(DefaultDir$)
run "regedit /e ";NowDir$;"\font.txt Hkey_Local_Machine\Software\Microsoft\Windows\CurrentVersion\Fonts", HIDE
files NowDir$, "font.txt", info$(
if val(info$(0, 0)) = 0 then
notice "Only for Windows 95/98 !"
end
end if
'sample entry in list: "Arial (TrueType)"="ARIAL.TTF"
fdir$ = "font.txt"
open fdir$ for input as #list 'load font list to array
while eof(#list)=0
f = f + 1
input #list, ttf$
if left$(ttf$,1) = chr$(34) then 'chr$(34) is double quote mark
fn = instr(ttf$, "(", 2)
fontList$(f) = Trim$(mid$(ttf$,2,fn-2))
print fontList$(f)
end if
[fpass]
wend
close #list
f = f + 1 : font$(f) = "Fixedsys" 'add fixedsys font
end
Function GetShortPathName$(lPath$)
lPath$=lPath$+Chr$(0)
sPath$=Space$(256)
lenPath=Len(sPath$)
CallDLL #kernel32, "GetShortPathNameA",lPath$ As ptr,_
sPath$ As ptr,lenPath As long,r As long
GetShortPathName$=Left$(sPath$,r)
End Function
=========================================================================
' WORKS ON ALL VERSIONS OF WINDOWS 95/98/XP etc
' Display or Printout of all Fonts installed. Most of
' the code for printing the fonts provided by Alyce at
' http://alyce.hytext.com/ from her Ebook. Registry search
' by Stefan at megabit@t-online.at Unprintable characters
' are removed with the additional CleanString$ function
' and saving to and reloading from list.txt
nomainwin
' Get O/S Version
struct OSVERSIONINFO,_
dwOSVersionInfoSize as ulong,_
dwMajorVersion as ulong,_
dwMinorVersion as ulong,_
dwBuildNumber as ulong,_
dwPlatformId as ulong,_
szCSDVersion as char[128]
L=len(OSVERSIONINFO.struct)
OSVERSIONINFO.dwOSVersionInfoSize.struct=L
calldll #kernel32, "GetVersionExA",_
OSVERSIONINFO as struct,_
result as boolean
' Determine wich SubKey to use
PlatformID = OSVERSIONINFO.dwPlatformId.struct
select case PlatformID
' we are running Win9x,ME
case _VER_PLATFORM_WIN32_WINDOWS
OSVersionKey$ = "Windows"
' we are running WinNT,2k,XP
case _VER_PLATFORM_WIN32_NT
OSVersionKey$ = "Windows NT"
' we are running perhaps Win3.x :-o
case else
notice "Application Error";chr$(13);"Unsupported Operatingsystem"
end
end select
xp = 1 : yp = 1
if DisplayWidth <> 1024 then xp = (DisplayWidth-1024)/2 : yp = (DisplayHeight-768)/2
dim font$(2000) : count = 1
' Avoid small screen flash
WindowWidth = DisplayWidth : WindowHeight = DisplayHeight
open "Searching for Font Samples" for graphics_nf_nsb as #s
#s "trapclose ; cls; font arial 24 bold"
#s "down; color red; place ";300+xp;" ";226+yp
tim2 = 1
#s "\CREATING THE FONT LIST\\PLEASE WAIT 5 SECONDS"
#s "flush" ' <<-- make graphics stick
tim = time$("seconds")
'** export font list from registry.
NowDir$=GetShortPathName$(DefaultDir$)
FontFile$=NowDir$+"\font.lst"
FontList$=NowDir$+"\font.txt"
run "regedit /e ";FontFile$;" ";_
chr$(34);"Hkey_Local_Machine\Software\Microsoft\";OSVersionKey$;_
"\CurrentVersion\Fonts";chr$(34),hide
while time$("seconds") < tim + 5
if time$("seconds") - tim = tim2 then
#s "place ";300+xp;" ";300+yp
#s "\PLEASE WAIT ";5-tim2;" SECONDS"
tim2 = tim2 +1
end if
wend
'sample entry in list: "Arial (TrueType)"="ARIAL.TTF"
open FontFile$ for input as #list ' open regeit list
open FontList$ for output as #new ' save ASCII list
while not(eof(#list))
line input #list, ttf$ ' some fonts contain commas
tn = instr(ttf$, chr$(34)) ' get start of fontname
if tn < 5 then
fn = instr(ttf$, "(") ' get end of fontname
if fn = 0 then fn = instr(ttf$, chr$(34), tn+1) 'some fonts contain no brackets
new$ = mid$(ttf$,tn+1,fn-tn-2) 'get the string between start and end
cleanfont$ = CleanString$(new$)
' skip blank data
if len(cleanfont$) > 2 then
#new cleanfont$
count = count + 1
end if
end if
wend
close #list : close #new
count = count -1
kill FontFile$ : count = 0
' Assign clean fonts to font$()
open FontList$ for input as #list
while eof(#list)=0
count = count + 1
line input #list, ttf$ ' some fonts contain commas
font$(count) = ttf$
wend
close #list
close #s ' new window
open "gdi32" for dll as #gdi
[new]
button #s,"Show All ",[list],ul,300+xp,255+yp
button #s," Single ",[single],ul,300+xp,300+yp
button #s," Multiple ",[multpl],ul,300+xp,345+yp
button #s," * QUIT * ",[quit],ul,300+xp,390+yp
open "Font Samples" for graphics_nf_nsb as #s
[which]
#s "trapclose [quit]; cls; font arial 24 bold; down"
#s "color blue; place ";320+xp;" ";100+yp
#s "\Samples of Printer Fonts."
#s "place ";410+xp;" ";130+yp
#s "\For Windows"
#s "font arial 14 bold; place ";400+xp;" ";275+yp
#s "\Display Fonts found"
#s "\\One font only any size, bold/italic"
#s "\\Up to 40 fonts all size 25 regular"
#s "\\Abort Program"
#s "color red; place ";360+xp;" ";500+yp
#s "\Total Found "; count;" in FONTS.LST"
sort font$(), 1, count
#s "color black; place ";10+xp;" ";100+yp
#s "flush" ' <<-- make graphics stick
playwave "notify.wav" : wait
[list]
start = 1
prompt "Enter first of 100 maximum to display"; start
if start > count then start = count - 99
po = 0 : last = start + 99
if last > count then last = count
[show]
close #s
button #s, "Continue", [go], LL 350, 1
button #s, "Stop", [stop], LL 450, 1
open "Samples of Fonts Found" for graphics_nf_nsb as #s
#s "cls; trapclose [quit]; down; place 10 20"
for n = start to last
#s "font ";font$(n);" 14"
#s "\";n;" ";font$(n)
#s "posxy x y"
if x<100 and y>680 then #s "place 470, 20"
if x>200 and y>680 then #s "flush" : wait
[nop]
next n
if po = 0 then [ok]
#s "color blue"
#s "\\Display fonts dpi 14"
#s "\Printout fonts dpi 25"
[ok]
notice "All Shown"
[stop]
n = 1
if po = 1 then [printit]
close #s : goto [new]
[go]
#s "cls; discard; place 10 20"
goto [nop]
[single]
single = 1 : #s "place 10 100; color black"
fontdialog "arial 10", Font$
if Font$ = "" then [quit]
Fname$ = word$(Font$,1)
if instr(Fname$, "_") > 0 then gosub [space]
text$ = Font$ ' Printout
tpi=val(word$(Font$,2)) ' in hundredths of inch
height = tpi/100
width = height * .6
fontweight = 0 ' default no bold
italic = 0 ' default no italic
if word$(Font$,3) = "bold" then bold = 1
if word$(Font$,3) = "italic" then italic = 1
if right$(Font$,11) = "bold italic" then
bold = 1
italic = 1
end if
if bold = 1 then fontweight = 1
font$(1) = Fname$
#s "cls; font ";Font$
#s "\";Font$
start =1 : last = 1 : goto [printit]
[multpl]
single = 0 : #s "place 10 20"
[repeat]
prompt "Enter first of 40 to printout"; start
last = start + 39
height = .25 : width = .15 : fontweight = 0 : italic = 0
po = 1 : goto [show]
[printit]
'Printing can be done with default printer, or with a printer dialog.
'Either use gosub [nodialog] or gosub [dialog], not both.
'gosub [nodialog] 'print with default printer
gosub [dialog] 'use api printer dialog
print "printer DC ";pDC
if pDC = 0 then 'trap error
notice "Unable to create a DC for Printer: " + PrtName$
close #gdi
end
end if
'returns dots per inch width, printer
calldll #gdi, "GetDeviceCaps",_
pDC as long,_
_LOGPIXELSX as long,_
dpix as long
'returns dots per inch height, printer
calldll #gdi, "GetDeviceCaps",_
pDC as long,_
_LOGPIXELSY as long,_
dpiy as long
'this struct is needed for StartDoc
struct docInfo, _
cbSize as long,_
lpszDocName$ as ptr,_
lpszOutput$ as ptr,_
lpszDatatype$ as ptr,_
fwType as ulong
docInfo.cbSize.struct=len(docInfo.struct)
docInfo.lpszDocName$.struct="Printer Test"+chr$(0)
'begins the print job
calldll #gdi, "StartDocA", _
pDC as long, _ 'the handle of the printer dc
docInfo as struct, _
result as long
'begins a new page
calldll #gdi, "StartPage", _
pDC as long, _ 'the handle of the printer dc
r as long
sp = .5 ' ***** START OF PRINT LOOP *****
for rep = start to last
fontname$ = font$(rep)
if single = 1 then text$ = Font$
if single = 0 then text$ = str$(rep);" ";fontname$
'set font attributes
fontheight = int(dpiy * height) 'default .25 inch high
fontwidth = int(dpix * width) 'default .15 inch wide
fontweight = 0 '1 = bold
italic = 0 '1 = italic text
underline = 0 ' 1 produces underlined text
fontname$ = fontname$ + chr$(0)
'create a font
Calldll #gdi, "CreateFontA",_
fontheight as long, fontwidth as long,_
escapement as long, orientation as long,_
weight as long, italic as long,_
underline as long, strikeout as long,_
CharSet as long, OutputPrecision as long,_
ClipPrecision as long, Quality as long,_
PitchAndFamily as long,fontname$ as PTR,_
newfont as long
'select font into printer device context
Calldll #gdi, "SelectObject",_
pDC as long,_ 'handle to the DC
newfont as long,_ 'handle to the new font
oldfont as long 'handle to the previous font
'set up text to print
text$ = text$ + chr$(0)
lengthtext=len(text$)-1
textx=dpix '1 inch from left
texty=dpiy*sp '2 inches from top
'send text to printer
calldll #gdi, "TextOutA", _
pDC as long,_ 'device context
textx as long,_ 'x origin of text
texty as long,_ 'y origin of text
text$ as ptr,_ 'text string to display
lengthtext as long,_'length of text string
result as long 'nonzero if successfull
sp = sp + .25
next rep '***** END OF PRINT LOOP ******
'eject page
calldll #gdi, "EndPage", _
pDC as long,_ 'the handle of the printer dc
result as long
'end printing session
calldll #gdi, "EndDoc", _
pDC as long,_ 'the handle of the printer dc
result as long
'delete font
Calldll #gdi, "DeleteObject",_
newfont as long,_ 'handle of font to delete
result as long 'nonzero if successful
'delete printer dc
calldll #gdi, "DeleteDC",_
pDC as long,_ 'the handle of the Printer DC
result as long 'a return of 0 indicates an error
close #s : goto [new]
[nodialog]
'setup values for GetProfileStringA
appName$ = "windows"
keyName$ = "device"
default$ = ""
result$ = space$(49)+chr$(0)
size = 50
'get printer and driver info
Open "kernel32" For DLL As #kernel
calldll #kernel, "GetProfileStringA",_
appName$ as ptr,_
keyName$ as ptr,_
default$ as ptr,_
result$ as ptr,_
size as long,_
result as long
close #kernel
profile$ = left$(result$, instr(result$, chr$(0)) - 1)
'parse returned string for individual members
j = instr(profile$, ",", 1)
PrtName$ = left$(profile$, j-1)
j = j + 1
k = instr(profile$, ",", j)
Driver$ = mid$(profile$, j, k-j)
Output$ = right$(profile$, len(profile$)-k)
Driver$ = Driver$ + chr$(0)
PrtName$ = PrtName$ + chr$(0)
Output$ = chr$(0)
Init$ = chr$(0)
'use driver info to create a Device context for printer
calldll #gdi , "CreateDCA", _
Driver$ as ptr, _
PrtName$ as ptr, _
Output$ as ptr, _
Init$ as ptr, _
pDC as long
RETURN
[dialog]
struct PD,_
lStructSize as ulong,_
hwndOwner as long,_
hDevMode as long,_
hDevNames as long,_
hDC as long,_
Flags as ulong,_
nFromPage as word,_
nToPage as word,_
nMinPage as word,_
nMaxPage as word,_
nCopies as word,_
hInstance as long,_
lCustData as ulong,_
lpfnPrintHook as long,_
lpfnSetupHook as long,_
lpPrintTemplateName as long,_
lpSetupTemplateName as long,_
hPrintTemplate as long,_
hSetupTemplate as long
PD.Flags.struct=_PD_RETURNDC
PD.lStructSize.struct=len(PD.struct)
open "comdlg32.dll" for dll as #cdlg
calldll #cdlg, "PrintDlgA",PD as struct, r as long
close #cdlg
pDC=PD.hDC.struct
RETURN
[space]
new$ = ""
for c = 1 to len(Fname$)
t$=mid$(Fname$,c,1)
if t$<>"_"then new$=new$+t$ else new$=new$+" "
next c
Fname$=new$ : return
[quit]
close #gdi
close #s
confirm "Delete Fonts list.txt ?"; q$
if q$ = "yes" then kill FontList$
end
Function GetShortPathName$(lPath$)
lPath$=lPath$+Chr$(0)
sPath$=Space$(256)
lenPath=Len(sPath$)
CallDLL #kernel32, "GetShortPathNameA",lPath$ As ptr,_
sPath$ As ptr,lenPath As long,r As long
GetShortPathName$=Left$(sPath$,r)
End Function
function CleanString$(string$)
CleanString$ = ""
for num = 1 to len(string$)
Char$ = mid$(string$,num,1)
if asc(Char$) >= 32 and asc(Char$) <= 122 then _
CleanString$ = CleanString$ + Char$
next
end function